home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / Chat 1.1.0 / source / PNL Libraries / MyUtils.unit < prev   
Encoding:
Text File  |  1992-11-19  |  9.4 KB  |  444 lines  |  [TEXT/PJMM]
  1. unit MyUtils;
  2.  
  3. interface
  4.  
  5.     type
  6.         versionRecord = packed record
  7.                 version: integer;
  8.                 devcode: byte;
  9.                 revision: byte;
  10.                 country: integer;
  11.                 short: str15;
  12.                 long: str255;
  13.             end;
  14.  
  15.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  16.     function MyNumToString (n: longInt): str255;
  17.     function NumToStr (n: longInt): str255;
  18.     function StrToNum (s: str255): longInt;
  19.     function GetIndexedString (strh, i: integer): str255;
  20.     procedure DotDotDot (var s: str255; var width: integer);
  21.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  22.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  23.     function GetIDItemEnable (menu, item: integer): boolean;
  24.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  25.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  26.     function MyFrontWindow: boolean;
  27.     function DAFrontWindow: boolean;
  28.     function GetIndStrSize (size, id, index: integer): str255;
  29.     procedure GetVersion (var vers: versionRecord);
  30.     procedure SetVersionParamText (c2, c3: str255);
  31.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  32.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  33.     procedure PlotSICN (id: integer; index, v, h: integer);
  34.     procedure SegmentInit;
  35.     procedure SegmentUtil;
  36.     procedure SegmentUtil2;
  37.     procedure SegmentTerm;
  38.     function HLockState (h: univ handle): signedByte;
  39. {    procedure SPrintS5V (var dst: str255;var  src,s1, s2, s3, s4, s5: str255);}
  40.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  41.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  42.     function UpCase (ch: char): char;
  43.     inline
  44.         $301F, $0C00, $0061, $6500, $000E, $0C00, $007B, $6400, $0006, $0400, $0020, $3E80;
  45.     procedure UpCaseString (var s: string);
  46.     procedure SmallMove (src, dst: ptr; count: longInt);
  47.     function LookupStrh (id: integer; match: str255): str255;
  48.     function TouchDir (fs: FSSpec): OSErr;
  49.  
  50. implementation
  51.  
  52.     uses
  53.         MyTypes, Traps;
  54.  
  55. {$S Init}
  56.     procedure SegmentInit;
  57.     begin
  58.     end;
  59.  
  60. {$S Util}
  61.     procedure SegmentUtil;
  62.     begin
  63.     end;
  64.  
  65. {$S Util2}
  66.     procedure SegmentUtil2;
  67.     begin
  68.     end;
  69.  
  70. {$S Term}
  71.     procedure SegmentTerm;
  72.     begin
  73.     end;
  74.  
  75. {$S Util}
  76.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  77. {Check to see if a given trap is implemented. Babble as taken from IM6 }
  78.         const
  79.             TrapMask = $0800;
  80.         var
  81.             tType: TrapType;
  82.             ignoreError: OSErr;
  83.     begin
  84.         if BAND(tNumber, TrapMask) > 0 then
  85.             tType := ToolTrap
  86.         else
  87.             tType := OSTrap;
  88.         if tType = ToolTrap then begin
  89.             tNumber := BAND(tNumber, $7FF);
  90.             if tNumber >= $400 then
  91.                 tNumber := _Unimplemented
  92.             else if tNumber >= $200 then
  93.                 if NGetTrapAddress($A86E, ToolTrap) <> NGetTrapAddress($AA6E, ToolTrap) then
  94.                     tNumber := _Unimplemented;
  95.         end;
  96.         TrapAvailable := NGetTrapAddress(tNumber, tType) <> GetTrapAddress(_Unimplemented);
  97.     end; {TrapAvailable}
  98.  
  99. {$S Util}
  100.     function MyNumToString (n: longInt): str255;
  101.         var
  102.             s: str255;
  103.     begin
  104.         if abs(n) < 4096 then
  105.             NumToString(n, s)
  106.         else if abs(n) < 4194304 then begin
  107.             NumToString(n div 1024, s);
  108.             s := Concat(s, 'k');
  109.         end
  110.         else begin
  111.             NumToString(n div 1048576, s);
  112.             s := Concat(s, 'M');
  113.         end;
  114.         MyNumToString := s;
  115.     end;
  116.  
  117. {$S Util}
  118.     function NumToStr (n: longInt): str255;
  119.         var
  120.             s: str255;
  121.     begin
  122.         NumToString(n, s);
  123.         NumToStr := s;
  124.     end;
  125.  
  126. {$S Util}
  127.     function StrToNum (s: str255): longInt;
  128.         var
  129.             n: longInt;
  130.     begin
  131.         StringToNum(s, n);
  132.         StrToNum := n;
  133.     end;
  134.  
  135. {$S Util}
  136.     function GetIndexedString (strh, i: integer): str255;
  137.         var
  138.             s: str255;
  139.     begin
  140.         GetIndString(s, strh, i);
  141.         GetIndexedString := s;
  142.     end;
  143.  
  144. {$S Util2}
  145.     procedure DotDotDot (var s: str255; var width: integer);
  146.         var
  147.             maxwidth, len: integer;
  148.     begin
  149.         maxwidth := width;
  150.         width := StringWidth(s);
  151.         if width > maxwidth then begin
  152.             width := width + CharWidth('…');
  153. {$PUSH}
  154. {$R-}
  155.             len := ord(s[0]);
  156.             while (len > 0) and (width > maxwidth) do begin
  157.                 width := width - CharWidth(s[len]);
  158.                 len := len - 1;
  159.             end;
  160.             len := len + 1;
  161.             s[0] := chr(len);
  162.             s[len] := '…';
  163. {$POP}
  164.         end;
  165.     end;
  166.  
  167. {$S}
  168.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  169.     begin
  170.         if enable then
  171.             EnableItem(mh, item)
  172.         else
  173.             DisableItem(mh, item);
  174.     end;
  175.  
  176. {$S}
  177.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  178.     begin
  179.         SetItemEnable(GetMHandle(menu), item, enable);
  180.     end;
  181.  
  182. {$S}
  183.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  184.     begin
  185.         if item > 31 then
  186.             GetItemEnable := true
  187.         else
  188.             GetItemEnable := BTST(mh^^.enableFlags, item);
  189.     end;
  190.  
  191. {$S}
  192.     function GetIDItemEnable (menu, item: integer): boolean;
  193.     begin
  194.         GetIDItemEnable := GetItemEnable(GetMHandle(menu), item);
  195.     end;
  196.  
  197. {$S Util2}
  198.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  199.     begin
  200.         if dotted then
  201.             SetItemMark(mh, item, '•')
  202.         else
  203.             SetItemMark(mh, item, chr(0));
  204.     end;
  205.  
  206. {$S Util2}
  207.     function MyFrontWindow: boolean;
  208.         var
  209.             wp: windowPtr;
  210.     begin
  211.         wp := FrontWindow;
  212.         if wp = nil then
  213.             MyFrontWindow := false
  214.         else
  215.             MyFrontWindow := windowPeek(wp)^.windowKind >= userKind;
  216.     end;
  217.  
  218. {$S Util2}
  219.     function DAFrontWindow: boolean;
  220.         var
  221.             wp: windowPtr;
  222.     begin
  223.         wp := FrontWindow;
  224.         if wp = nil then
  225.             DAFrontWindow := false
  226.         else
  227.             DAFrontWindow := windowPeek(wp)^.windowKind < 0;
  228.     end;
  229.  
  230. {$S Util2}
  231.     function GetIndStrSize (size, id, index: integer): str255;
  232.         var
  233.             s255: str255;
  234.     begin
  235.         GetIndString(s255, id, index);
  236.         GetIndStrSize := copy(s255, 1, size - 1);
  237.     end;
  238.  
  239. {$S Util}
  240.     procedure GetVersion (var vers: versionRecord);
  241.         var
  242.             vh: handle;
  243.     begin
  244.         with vers do begin
  245.             vh := GetResource('vers', 1);
  246.             if vh = nil then begin
  247.                 version := $0000;
  248.                 devcode := $20;
  249.                 revision := $00;
  250.                 country := 0;
  251.                 short := '0.0.0';
  252.                 long := 'Unknown v0.0.0';
  253.             end
  254.             else begin
  255.                 BlockMove(vh^, @vers, sizeof(vers));
  256. {$PUSH}
  257.  {$R-}
  258.                 BlockMove(Ptr(longint(vh^) + (longint(@short) - longint(@vers)) + ord(short[0]) + 1), @long, sizeof(long));
  259.                 if ord(short[0]) >= sizeof(short) then
  260.                     short[0] := chr(sizeof(short) - 1);
  261. {$POP}
  262.                 ReleaseResource(vh);
  263.             end;
  264.         end;
  265.     end;
  266.  
  267. {$S Util}
  268.     procedure SetVersionParamText (c2, c3: str255);
  269.         var
  270.             vers: versionRecord;
  271.     begin
  272.         GetVersion(vers);
  273.         ParamText(vers.short, vers.long, c2, c3);
  274.     end;
  275.  
  276. {$S Util}
  277.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  278.         var
  279.             procID: longInt;
  280.             oe: OSErr;
  281.     begin
  282.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  283.         if oe <> noErr then begin
  284.             vrn := wdrn;
  285.             dirID := 0;
  286.         end;
  287.         GetDirID := oe;
  288.     end;
  289.  
  290. {$S Util2}
  291.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  292.         var
  293.             pb: paramBlockRec;
  294.             oe: OSErr;
  295.     begin
  296.         with pb do begin
  297.             if (name <> '') & (name[length(name)] <> ':') then
  298.                 name := concat(name, ':');
  299.             pb.ioNamePtr := @name;
  300.             ioVRefNum := vrn;
  301.             ioVolIndex := index;
  302.             oe := PBGetVInfo(@pb, false);
  303.             if oe = noErr then begin
  304.                 vrn := ioVRefNum;
  305.                 CrDate := ioVCrDate;
  306.             end;
  307.         end;
  308.         GetVolInfo := oe;
  309.     end;
  310.  
  311. {$S Util}
  312.     procedure PlotSICN (id: integer; index, v, h: integer);
  313.         var
  314.             sh: Handle;
  315.             bm: BitMap;
  316.             r: Rect;
  317.             gp: grafptr;
  318.     begin
  319.         sh := GetResource('SICN', id);
  320.         HLock(sh);
  321.         bm.baseAddr := Ptr(longInt(sh^) + (index - 1) * 32);
  322.         bm.rowBytes := 2;
  323.         SetRect(r, h, v, h + 16, v + 16);
  324.         bm.bounds := r;
  325.         GetPort(gp);
  326.         CopyBits(bm, gp^.portBits, r, r, srcCopy, nil);
  327.         HUnlock(sh);
  328.     end;
  329.  
  330.     function HLockState (h: univ handle): signedByte;
  331.     begin
  332.         HLockState := HGetState(h);
  333.         HLock(h);
  334.     end;
  335.  
  336.     procedure DoSub (var dst: str255; n: integer; var s: str255);
  337.         var
  338.             p: integer;
  339.     begin
  340.         p := Pos(concat('^', chr(n + 48)), dst);
  341.         if p > 0 then begin
  342.             Delete(dst, p, 2);
  343.             Insert(s, dst, p);
  344.         end;
  345.     end;
  346.  
  347. {$Z+}
  348.     procedure SPrintS5V (var dst: str255; var src, s1, s2, s3, s4, s5: str255);
  349.     begin
  350.         dst := src;
  351.         DoSub(dst, 5, s5);
  352.         DoSub(dst, 4, s4);
  353.         DoSub(dst, 3, s3);
  354.         DoSub(dst, 2, s2);
  355.         DoSub(dst, 1, s1);
  356.     end;
  357. {$Z-}
  358.  
  359.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  360.     begin
  361.         SPrintS5V(dst, src, s1, s2, s3, s4, s5);
  362.     end;
  363.  
  364.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  365.     begin
  366.         dst := src;
  367.         DoSub(dst, 3, s3);
  368.         DoSub(dst, 2, s2);
  369.         DoSub(dst, 1, s1);
  370.     end;
  371.  
  372.     function UpCaseProcedure (ch: char): char;
  373.     begin
  374.         if ('a' <= ch) and (ch <= 'z') then
  375.             UpCaseProcedure := chr(ord(ch) - $20)
  376.         else
  377.             UpCaseProcedure := ch;
  378.     end;
  379.  
  380.     procedure SmallMove (src, dst: ptr; count: longInt);
  381.     begin
  382.         while count > 0 do begin
  383.             src^ := dst^;
  384.             longInt(src) := longInt(src) + 1;
  385.             longInt(dst) := longInt(dst) + 1;
  386.             count := count - 1;
  387.         end;
  388.     end;
  389.  
  390.     function LookupStrh (id: integer; match: str255): str255;
  391.         var
  392.             t, s: str255;
  393.             i: integer;
  394.     begin
  395.         t := '';
  396.         i := 1;
  397.         repeat
  398.             GetIndString(s, id, i);
  399.             if s = match then begin
  400.                 GetIndString(t, id, i + 1);
  401.                 leave;
  402.             end;
  403.             i := i + 2;
  404.         until s = '';
  405.         LookupStrh := t;
  406.     end;
  407.  
  408.     function TouchDir (fs: FSSpec): OSErr;
  409.         var
  410.             pb: CInfoPBRec;
  411.             oe: OSErr;
  412.     begin
  413.         pb.ioVRefNum := fs.vRefNum;
  414.         pb.ioDrDirID := fs.parID;
  415.         if fs.name = '' then
  416.             pb.ioNamePtr := nil
  417.         else
  418.             pb.ioNamePtr := @fs.name;
  419.         pb.ioFDirIndex := 0;
  420.  
  421.         oe := PBGetCatInfo(@pb, false);
  422.  
  423.         if oe = noErr then begin
  424.  
  425.             pb.ioDrDirID := pb.ioDrParID;
  426.             pb.ioFDirIndex := 0;
  427.             GetDateTime(pb.ioDrMdDat);
  428.  
  429.             oe := PBSetCatInfo(@pb, false);
  430.         end;
  431.  
  432.         TouchDir := oe;
  433.     end;
  434.  
  435.     procedure UpCaseString (var s: string);
  436.         var
  437.             i: integer;
  438.     begin
  439.         for i := 1 to length(s) do begin
  440.             s[i] := UpCase(s[i]);
  441.         end;
  442.     end;
  443.  
  444. end.